Aminet 1/Aminet - June 1993 [Walnut Creek].iso/usenet/sources/volume90/aplictns/xscheme2/part04

Internet Message Format | 1990-04-14 | 50.5 KB

Path: xanth!cs.odu.edu!Amiga-Request
From: [e-mail] (Amiga Sources/Binaries Moderator)
Newsgroups: comp.sources.amiga
Subject: v90i142: XScheme 0.20 - an object-oriented scheme, Part04/07
Message-ID: <[e-mail]>
Date: 14 Apr 90 21:11:35 GMT
Sender: [e-mail]
Reply-To: [e-mail] (Rusty Haddock)
Lines: 2311
Approved: [e-mail] (Tad Guy)
X-Mail-Submissions-To: [e-mail]
X-Post-Discussions-To: comp.sys.amiga

Submitted-by: [e-mail] (Rusty Haddock)
Posting-number: Volume 90, Issue 142
Archive-name: applications/xscheme-0.20/part04

#!/bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 4 (of 7)."
# Contents:  Src/xsfun1.c Src/xsfun2.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:26 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/xsfun1.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xsfun1.c'\"
else
echo shar: Extracting \"'Src/xsfun1.c'\" \(19708 characters\)
sed "s/^X//" >'Src/xsfun1.c' <<'END_OF_FILE'
X/* xsfun1.c - xscheme built-in functions - part 1 */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X
X/* gensym variables */
Xstatic char gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
Xstatic int gsnumber = 1;            /* gensym number */
X
X/* external variables */
Xextern LVAL xlenv,xlval,default_object,true;
Xextern LVAL s_unbound;
X
X/* external routines */
Xextern int eq(),eqv(),equal();
X
X/* forward declarations */
XFORWARD LVAL cxr();
XFORWARD LVAL member();
XFORWARD LVAL assoc();
XFORWARD LVAL nth();
XFORWARD LVAL eqtest();
X
X/* xcons - construct a new list cell */
XLVAL xcons()
X{
X    LVAL carval,cdrval;
X
X    /* get the two arguments */
X    carval = xlgetarg();
X    cdrval = xlgetarg();
X    xllastarg();
X
X    /* construct a new cons node */
X    return (cons(carval,cdrval));
X}
X
X/* xcar - built-in function 'car' */
XLVAL xcar()
X{
X    LVAL list;
X    list = xlgalist();
X    xllastarg();
X    return (list ? car(list) : NIL);
X}
X
X/* xicar - built-in function '%car' */
XLVAL xicar()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (car(arg));
X}
X
X/* xcdr - built-in function 'cdr' */
XLVAL xcdr()
X{
X    LVAL arg;
X    arg = xlgalist();
X    xllastarg();
X    return (arg ? cdr(arg) : NIL);
X}
X
X/* xicdr - built-in function '%cdr' */
XLVAL xicdr()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (cdr(arg));
X}
X
X/* cxxr functions */
XLVAL xcaar() { return (cxr("aa")); }
XLVAL xcadr() { return (cxr("da")); }
XLVAL xcdar() { return (cxr("ad")); }
XLVAL xcddr() { return (cxr("dd")); }
X
X/* cxxxr functions */
XLVAL xcaaar() { return (cxr("aaa")); }
XLVAL xcaadr() { return (cxr("daa")); }
XLVAL xcadar() { return (cxr("ada")); }
XLVAL xcaddr() { return (cxr("dda")); }
XLVAL xcdaar() { return (cxr("aad")); }
XLVAL xcdadr() { return (cxr("dad")); }
XLVAL xcddar() { return (cxr("add")); }
XLVAL xcdddr() { return (cxr("ddd")); }
X
X/* cxxxxr functions */
XLVAL xcaaaar() { return (cxr("aaaa")); }
XLVAL xcaaadr() { return (cxr("daaa")); }
XLVAL xcaadar() { return (cxr("adaa")); }
XLVAL xcaaddr() { return (cxr("ddaa")); }
XLVAL xcadaar() { return (cxr("aada")); }
XLVAL xcadadr() { return (cxr("dada")); }
XLVAL xcaddar() { return (cxr("adda")); }
XLVAL xcadddr() { return (cxr("ddda")); }
XLVAL xcdaaar() { return (cxr("aaad")); }
XLVAL xcdaadr() { return (cxr("daad")); }
XLVAL xcdadar() { return (cxr("adad")); }
XLVAL xcdaddr() { return (cxr("ddad")); }
XLVAL xcddaar() { return (cxr("aadd")); }
XLVAL xcddadr() { return (cxr("dadd")); }
XLVAL xcdddar() { return (cxr("addd")); }
XLVAL xcddddr() { return (cxr("dddd")); }
X
X/* cxr - common car/cdr routine */
XLOCAL LVAL cxr(adstr)
X  char *adstr;
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* perform the car/cdr operations */
X    while (*adstr && consp(list))
X    list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X    /* make sure the operation succeeded */
X    if (*adstr && list)
X    xlbadtype(list);
X
X    /* return the result */
X    return (list);
X}
X
X/* xsetcar - built-in function 'set-car!' */
XLVAL xsetcar()
X{
X    LVAL arg,newcar;
X
X    /* get the cons and the new car */
X    arg = xlgacons();
X    newcar = xlgetarg();
X    xllastarg();
X
X    /* replace the car */
X    rplaca(arg,newcar);
X    return (arg);
X}
X
X/* xisetcar - built-in function '%set-car!' */
XLVAL xisetcar()
X{
X    LVAL arg,newcar;
X
X    /* get the cons and the new car */
X    arg = xlgetarg();
X    newcar = xlgetarg();
X    xllastarg();
X
X    /* replace the car */
X    rplaca(arg,newcar);
X    return (arg);
X}
X
X/* xsetcdr - built-in function 'set-cdr!' */
XLVAL xsetcdr()
X{
X    LVAL arg,newcdr;
X
X    /* get the cons and the new cdr */
X    arg = xlgacons();
X    newcdr = xlgetarg();
X    xllastarg();
X
X    /* replace the cdr */
X    rplacd(arg,newcdr);
X    return (arg);
X}
X
X/* xisetcdr - built-in function '%set-cdr!' */
XLVAL xisetcdr()
X{
X    LVAL arg,newcdr;
X
X    /* get the cons and the new cdr */
X    arg = xlgetarg();
X    newcdr = xlgetarg();
X    xllastarg();
X
X    /* replace the cdr */
X    rplacd(arg,newcdr);
X    return (arg);
X}
X
X/* xlist - built-in function 'list' */
XLVAL xlist()
X{
X    LVAL last,next,val;
X
X    /* initialize the list */
X    val = NIL;
X
X    /* add each argument to the list */
X    if (moreargs()) {
X        val = last = cons(nextarg(),NIL);
X        while (moreargs()) {
X        next = nextarg();
X        push(val);
X        next = cons(next,NIL);
X        rplacd(last,next);
X        last = next;
X        val = pop();
X    }
X    }
X
X    /* return the list */
X    return (val);
X}
X
X/* xappend - built-in function 'append' */
XLVAL xappend()
X{
X    LVAL next,this,last,val;
X
X    /* append each argument */
X    for (val = last = NIL; xlargc > 1; )
X
X    /* append each element of this list to the result list */
X    for (next = xlgalist(); consp(next); next = cdr(next)) {
X        push(val);
X        this = cons(car(next),NIL);
X        val = pop();
X        if (last == NIL) val = this;
X        else rplacd(last,this);
X        last = this;
X    }
X
X    /* tack on the last argument */
X    if (moreargs()) {
X    if (last == NIL) val = xlgetarg();
X    else rplacd(last,xlgetarg());
X    }
X
X    /* return the list */
X    return (val);
X}
X
X/* xreverse - built-in function 'reverse' */
XLVAL xreverse()
X{
X    LVAL next,val;
X
X    /* get the list to reverse */
X    next = xlgalist();
X    xllastarg();
X
X    /* append each element of this list to the result list */
X    for (val = NIL; consp(next); next = cdr(next)) {
X    push(val);
X    val = cons(car(next),top());
X    drop(1);
X    }
X
X    /* return the list */
X    return (val);
X}
X
X/* xlastpair - built-in function 'last-pair' */
XLVAL xlastpair()
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* find the last cons */
X    if (consp(list))
X    while (consp(cdr(list)))
X        list = cdr(list);
X
X    /* return the last element */
X    return (list);
X}
X
X/* xlength - built-in function 'length' */
XLVAL xlength()
X{
X    FIXTYPE n;
X    LVAL arg;
X
X    /* get the argument */
X    arg = xlgalist();
X    xllastarg();
X
X    /* find the length */
X    for (n = (FIXTYPE)0; consp(arg); ++n)
X    arg = cdr(arg);
X
X    /* return the length */
X    return (cvfixnum(n));
X}
X
X/* xmember - built-in function 'member' */
XLVAL xmember()
X{
X    return (member(equal));
X}
X
X/* xmemv - built-in function 'memv' */
XLVAL xmemv()
X{
X    return (member(eqv));
X}
X
X/* xmemq - built-in function 'memq' */
XLVAL xmemq()
X{
X    return (member(eq));
X}
X
X/* member - common routine for member/memv/memq */
XLOCAL LVAL member(fcn)
X  int (*fcn)();
X{
X    LVAL x,list,val;
X
X    /* get the expression to look for and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xllastarg();
X
X    /* look for the expression */
X    for (val = NIL; consp(list); list = cdr(list))
X    if ((*fcn)(x,car(list))) {
X        val = list;
X        break;
X    }
X
X    /* return the result */
X    return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XLVAL xassoc()
X{
X    return (assoc(equal));
X}
X
X/* xassv - built-in function 'assv' */
XLVAL xassv()
X{
X    return (assoc(eqv));
X}
X
X/* xassq - built-in function 'assq' */
XLVAL xassq()
X{
X    return (assoc(eq));
X}
X
X/* assoc - common routine for assoc/assv/assq */
XLOCAL LVAL assoc(fcn)
X  int (*fcn)();
X{
X    LVAL x,alist,pair,val;
X
X    /* get the expression to look for and the association list */
X    x = xlgetarg();
X    alist = xlgalist();
X    xllastarg();
X
X    /* look for the expression */
X    for (val = NIL; consp(alist); alist = cdr(alist))
X    if ((pair = car(alist)) && consp(pair))
X        if ((*fcn)(x,car(pair),fcn)) {
X        val = pair;
X        break;
X        }
X
X    /* return the result */
X    return (val);
X}
X
X/* xlistref - built-in function 'list-ref' */
XLVAL xlistref()
X{
X    return (nth(TRUE));
X}
X
X/* xlisttail - built-in function 'list-tail' */
XLVAL xlisttail()
X{
X    return (nth(FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL LVAL nth(carflag)
X  int carflag;
X{
X    LVAL list,arg;
X    int n;
X
X    /* get n and the list */
X    list = xlgalist();
X    arg = xlgafixnum();
X    xllastarg();
X
X    /* range check the index */
X    if ((n = (int)getfixnum(arg)) < 0)
X    xlerror("index out of range",arg);
X
X    /* find the nth element */
X    for (; consp(list) && n; n--)
X    list = cdr(list);
X
X    /* make sure the list was long enough */
X    if (n)
X    xlerror("index out of range",arg);
X
X    /* return the list beginning at the nth element */
X    return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xboundp - is this a value bound to this symbol? */
XLVAL xboundp()
X{
X    LVAL sym;
X    sym = xlgasymbol();
X    xllastarg();
X    return (boundp(sym) ? true : NIL);
X}
X
X/* xsymvalue - get the value of a symbol */
XLVAL xsymvalue()
X{
X    LVAL sym;
X    sym = xlgasymbol();
X    xllastarg();
X    return (getvalue(sym));
X}
X
X/* xsetsymvalue - set the value of a symbol */
XLVAL xsetsymvalue()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X
X    /* set the global value */
X    setvalue(sym,val);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymplist - get the property list of a symbol */
XLVAL xsymplist()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* return the property list */
X    return (getplist(sym));
X}
X
X/* xsetsymplist - set the property list of a symbol */
XLVAL xsetsymplist()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X
X    /* set the property list */
X    setplist(sym,val);
X    return (val);
X}
X
X/* xget - get the value of a property */
XLVAL xget()
X{
X    LVAL sym,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* retrieve the property value */
X    return (xlgetprop(sym,prp));
X}
X
X/* xput - set the value of a property */
XLVAL xput()
X{
X    LVAL sym,val,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    prp = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X
X    /* set the property value */
X    xlputprop(sym,val,prp);
X
X    /* return the value */
X    return (val);
X}
X
X/* xtheenvironment - built-in function 'the-environment' */
XLVAL xtheenvironment()
X{
X    xllastarg();
X    return (xlenv);
X}
X
X/* xprocenvironment - built-in function 'procedure-environment' */
XLVAL xprocenvironment()
X{
X    LVAL arg;
X    arg = xlgaclosure();
X    xllastarg();
X    return (getenv(arg));
X}
X
X/* xenvp - built-in function 'environment?' */
XLVAL xenvp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (envp(arg) ? true : NIL);
X}
X
X/* xenvbindings - built-in function 'environment-bindings' */
XLVAL xenvbindings()
X{
X    LVAL env,frame,names,val,this,last;
X    int len,i;
X
X    /* get the environment */
X    env = xlgetarg();
X    xllastarg();
X
X    /* check the argument type */
X    if (closurep(env))
X    env = getenv(env);
X    else if (!envp(env))
X    xlbadtype(env);
X
X    /* initialize */
X    frame = car(env);
X    names = getelement(frame,0);
X    len = getsize(frame);
X    check(1);
X
X    /* build a list of dotted pairs */
X    for (val = last = NIL, i = 1; i < len; ++i, names = cdr(names)) {
X    push(val);
X    this = cons(cons(car(names),getelement(frame,i)),NIL);
X    val = pop();
X    if (last) rplacd(last,this);
X    else val = this;
X    last = this;
X    }
X    return (val);
X}
X
X/* xenvparent - built-in function 'environment-parent' */
XLVAL xenvparent()
X{
X    LVAL env;
X    env = xlgaenv();
X    xllastarg();
X    return (cdr(env));
X}
X
X/* xvector - built-in function 'vector' */
XLVAL xvector()
X{
X    LVAL vect,*p;
X    vect = newvector(xlargc);
X    for (p = &vect->n_vdata[0]; moreargs(); )
X    *p++ = xlgetarg();
X    return (vect);
X}
X
X/* xmakevector - built-in function 'make-vector' */
XLVAL xmakevector()
X{
X    LVAL arg,val,*p;
X    int len;
X
X    /* get the vector size */
X    arg = xlgafixnum();
X    len = (int)getfixnum(arg);
X
X    /* check for an initialization value */
X    if (moreargs()) {
X    arg = xlgetarg();    /* get the initializer */
X    xllastarg();        /* make sure that's the last argument */
X    cpush(arg);        /* save the initializer */
X    val = newvector(len);    /* create the vector */
X    p = &val->n_vdata[0];    /* initialize the vector */
X    for (arg = pop(); --len >= 0; )
X        *p++ = arg;
X    }
X
X    /* no initialization value */
X    else
X    val = newvector(len);    /* defaults to initializing to NIL */
X
X    /* return the new vector */
X    return (val);
X}
X
X/* xvlength - built-in function 'vector-length' */
XLVAL xvlength()
X{
X    LVAL arg;
X    arg = xlgavector();
X    xllastarg();
X    return (cvfixnum((FIXTYPE)getsize(arg)));
X}
X
X/* xivlength - built-in function '%vector-length' */
XLVAL xivlength()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (cvfixnum((FIXTYPE)getsize(arg)));
X}
X
X/* xvref - built-in function 'vector-ref' */
XLVAL xvref()
X{
X    LVAL vref();
X    return (vref(xlgavector()));
X}
X
X/* xivref - built-in function '%vector-ref' */
XLVAL xivref()
X{
X    LVAL vref();
X    return (vref(xlgetarg()));
X}
X
X/* vref - common code for xvref and xivref */
XLOCAL LVAL vref(vector)
X  LVAL vector;
X{
X    LVAL index;
X    int i;
X
X    /* get the index */
X    index = xlgafixnum();
X    xllastarg();
X
X    /* range check the index */
X    if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
X    xlerror("index out of range",index);
X
X    /* return the vector element */
X    return (getelement(vector,i));
X}
X
X/* xvset - built-in function 'vector-set!' */
XLVAL xvset()
X{
X    LVAL vset();
X    return (vset(xlgavector()));
X}
X
X/* xivset - built-in function '%vector-set!' */
XLVAL xivset()
X{
X    LVAL vset();
X    return (vset(xlgetarg()));
X}
X
X/* vset - common code for xvset and xivset */
XLOCAL LVAL vset(vector)
X  LVAL vector;
X{
X    LVAL index,val;
X    int i;
X
X    /* get the index and the new value */
X    index = xlgafixnum();
X    val = xlgetarg();
X    xllastarg();
X
X    /* range check the index */
X    if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
X    xlerror("index out of range",index);
X
X    /* set the vector element and return the value */
X    setelement(vector,i,val);
X    return (val);
X}
X
X/* xvectlist - built-in function 'vector->list' */
XLVAL xvectlist()
X{
X    LVAL vect;
X    int size;
X
X    /* get the vector */
X    vect = xlgavector();
X    xllastarg();
X
X    /* make a list from the vector */
X    cpush(vect);
X    size = getsize(vect);
X    for (xlval = NIL; --size >= 0; )
X    xlval = cons(getelement(vect,size),xlval);
X    drop(1);
X    return (xlval);
X}
X
X/* xlistvect - built-in function 'list->vector' */
XLVAL xlistvect()
X{
X    LVAL vect,*p;
X    int size;
X
X    /* get the list */
X    xlval = xlgalist();
X    xllastarg();
X
X    /* make a vector from the list */
X    size = length(xlval);
X    vect = newvector(size);
X    for (p = &vect->n_vdata[0]; --size >= 0; xlval = cdr(xlval))
X    *p++ = car(xlval);
X    return (vect);
X}
X
X/* xmakearray - built-in function 'make-array' */
XLVAL xmakearray()
X{
X    LVAL makearray1(),val;
X    val = makearray1(xlargc,xlsp);
X    drop(xlargc);
X    return (val);
X}
X
XLVAL makearray1(argc,argv)
X  int argc; LVAL *argv;
X{
X    int size,i;
X    LVAL arg;
X
X    /* check for the end of the list of dimensions */
X    if (--argc < 0)
X    return (NIL);
X
X    /* get this dimension */
X    arg = *argv++;
X    if (!fixp(arg))
X    xlbadtype(arg);
X    size = (int)getfixnum(arg);
X
X    /* make the new array */
X    cpush(newvector(size));
X
X    /* fill the array and return it */
X    for (i = 0; i < size; ++i)
X    setelement(top(),i,makearray1(argc,argv));
X    return (pop());
X}
X
X/* xaref - built-in function 'array-ref' */
XLVAL xaref()
X{
X    LVAL array,index;
X    int i;
X
X    /* get the array */
X    array = xlgavector();
X
X    /* get each array index */
X    while (xlargc > 1) {
X    index = xlgafixnum(); i = (int)getfixnum(index);
X    if (i < 0 || i > getsize(array))
X        xlerror("index out of range",index);
X    array = getelement(array,i);
X    if (!vectorp(array))
X        xlbadtype(array);
X    }
X    cpush(array); ++xlargc;
X    return (xvref());
X}
X
X/* xaset - built-in function 'array-set!' */
XLVAL xaset()
X{
X    LVAL array,index;
X    int i;
X
X    /* get the array */
X    array = xlgavector();
X
X    /* get each array index */
X    while (xlargc > 2) {
X    index = xlgafixnum(); i = (int)getfixnum(index);
X    if (i < 0 || i > getsize(array))
X        xlerror("index out of range",index);
X    array = getelement(array,i);
X    if (!vectorp(array))
X        xlbadtype(array);
X    }
X    cpush(array); ++xlargc;
X    return (xvset());
X}
X
X/* xnull - built-in function 'null?' */
XLVAL xnull()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (null(arg) ? true : NIL);
X}
X
X/* xatom - built-in function 'atom?' */
XLVAL xatom()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (atom(arg) ? true : NIL);
X}
X
X/* xlistp - built-in function 'list?' */
XLVAL xlistp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (listp(arg) ? true : NIL);
X}
X
X/* xnumberp - built-in function 'number?' */
XLVAL xnumberp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (numberp(arg) ? true : NIL);
X}
X
X/* xbooleanp - built-in function 'boolean?' */
XLVAL xbooleanp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (arg == true || arg == NIL ? true : NIL);
X}
X
X/* xpairp - built-in function 'pair?' */
XLVAL xpairp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (consp(arg) ? true : NIL);
X}
X
X/* xsymbolp - built-in function 'symbol?' */
XLVAL xsymbolp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (symbolp(arg) ? true : NIL);
X}
X
X/* xintegerp - built-in function 'integer?' */
XLVAL xintegerp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (fixp(arg) ? true : NIL);
X}
X
X/* xrealp - built-in function 'real?' */
XLVAL xrealp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (floatp(arg) ? true : NIL);
X}
X
X/* xcharp - built-in function 'char?' */
XLVAL xcharp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (charp(arg) ? true : NIL);
X}
X
X/* xstringp - built-in function 'string?' */
XLVAL xstringp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (stringp(arg) ? true : NIL);
X}
X
X/* xvectorp - built-in function 'vector?' */
XLVAL xvectorp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (vectorp(arg) ? true : NIL);
X}
X
X/* xprocedurep - built-in function 'procedure?' */
XLVAL xprocedurep()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (closurep(arg) ? true : NIL);
X}
X
X/* xobjectp - built-in function 'object?' */
XLVAL xobjectp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (closurep(arg) ? true : NIL);
X}
X
X/* xdefaultobjectp - built-in function 'default-object?' */
XLVAL xdefaultobjectp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (arg == default_object ? true : NIL);
X}
X
X/* xeq - built-in function 'eq?' */
XLVAL xeq()
X{
X    return (eqtest(eq));
X}
X
X/* xeqv - built-in function 'eqv?' */
XLVAL xeqv()
X{
X    return (eqtest(eqv));
X}
X
X/* xequal - built-in function 'equal?' */
XLVAL xequal()
X{
X    return (eqtest(equal));
X}
X
X/* eqtest - common code for eq?/eqv?/equal? */
XLOCAL LVAL eqtest(fcn)
X  int (*fcn)();
X{
X    LVAL arg1,arg2;
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X    return ((*fcn)(arg1,arg2) ? true : NIL);
X}
X
X/* xgensym - generate a symbol */
XLVAL xgensym()
X{
X    char sym[STRMAX+11]; /* enough space for prefix and number */
X    LVAL x;
X
X    /* get the prefix or number */
X    if (moreargs()) {
X    x = xlgetarg();
X    switch (ntype(x)) {
X    case SYMBOL:
X        x = getpname(x);
X    case STRING:
X        strncpy(gsprefix,getstring(x),STRMAX);
X        gsprefix[STRMAX] = '\0';
X        break;
X    case FIXNUM:
X        gsnumber = getfixnum(x);
X        break;
X    default:
X        xlerror("bad argument type",x);
X    }
X    }
X    xllastarg();
X
X    /* create the pname of the new symbol */
X    sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X    /* make a symbol with this print name */
X    return (cvsymbol(sym));
X}
END_OF_FILE
if test 19708 -ne `wc -c <'Src/xsfun1.c'`; then
    echo shar: \"'Src/xsfun1.c'\" unpacked with wrong size!
fi
# end of 'Src/xsfun1.c'
fi
if test -f 'Src/xsfun2.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xsfun2.c'\"
else
echo shar: Extracting \"'Src/xsfun2.c'\" \(27271 characters\)
sed "s/^X//" >'Src/xsfun2.c' <<'END_OF_FILE'
X/* xsfun2.c - xscheme built-in functions - part 2 */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X
X/* external variables */
Xextern jmp_buf top_level;
Xextern LVAL eof_object,true;
Xextern LVAL xlfun,xlenv,xlval;
Xextern int prbreadth,prdepth;
Xextern FILE *tfp;
X
X/* external routines */
Xextern xlprin1(),xlprinc();
X
X/* forward declarations */
XFORWARD LVAL setit();
XFORWARD LVAL strcompare();
XFORWARD LVAL chrcompare();
X
X/* xapply - built-in function 'apply' */
XLVAL xapply()
X{
X    LVAL args,*p;
X
X    /* get the function and argument list */
X    xlval = xlgetarg();
X    args = xlgalist();
X    xllastarg();
X
X    /* get the argument count and make space on the stack */
X    xlargc = length(args);
X    check(xlargc);
X
X    /* copy the arguments onto the stack */
X    for (xlsp -= xlargc, p = xlsp; consp(args); args = cdr(args))
X    *p++ = car(args);
X
X    /* apply the function to the arguments */
X    xlapply();
X}
X
X/* xcallcc - built-in function 'call-with-current-continuation' */
XLVAL xcallcc()
X{
X    LVAL cont,*src,*dst;
X    int size;
X
X    /* get the function to call */
X    xlval = xlgetarg();
X    xllastarg();
X
X    /* create a continuation object */
X    size = (int)(xlstktop - xlsp);
X    cont = newcontinuation(size);
X    for (src = xlsp, dst = &cont->n_vdata[0]; --size >= 0; )
X    *dst++ = *src++;
X
X    /* setup the argument list */
X    cpush(cont);
X    xlargc = 1;
X
X    /* apply the function */
X    xlapply();
X}
X
X/* xmap - built-in function 'map' */
XLVAL xmap()
X{
X    if (xlargc < 2) xltoofew();
X    xlval = NIL;
X    do_maploop(NIL);
X}
X
X/* do_maploop - setup for the next application */
Xdo_maploop(last)
X  LVAL last;
X{
X    extern LVAL cs_map1;
X    LVAL *oldsp,*p,x;
X    int cnt;
X
X    /* get a pointer to the end of the argument list */
X    p = &xlsp[xlargc];
X    oldsp = xlsp;
X
X    /* save a continuation */
X    if (xlval) { check(5); push(xlval); push(last); }
X    else       { check(4); push(NIL); }
X    push(cvfixnum((FIXTYPE)xlargc));
X    push(cs_map1);
X    push(xlenv);
X
X    /* build the argument list for the next application */
X    for (cnt = xlargc; --cnt >= 1; ) {
X    x = *--p;
X    if (consp(x)) {
X        cpush(car(x));
X        *p = cdr(x);
X    }
X    else {
X        xlsp = oldsp;
X        drop(xlargc);
X        xlreturn();
X        return;
X    }
X    }
X    xlval = *--p;    /* get the function to apply */
X    xlargc -= 1;    /* count shouldn't include the function itself */
X    xlapply();        /* apply the function */
X}
X
X/* xmap1 - continuation for xmap */
XLVAL xmap1()
X{
X    LVAL last,tmp;
X
X    /* get the argument count */
X    tmp = pop();
X
X    /* get the tail of the value list */
X    if (last = pop()) {
X    rplacd(last,cons(xlval,NIL));    /* add the new value to the tail */
X    last = cdr(last);        /* remember the new tail */
X    xlval = pop();            /* restore the head of the list */
X    }
X    else
X    xlval = last = cons(xlval,NIL);    /* build the initial value list */
X
X    /* convert the argument count and loop */
X    xlargc = (int)getfixnum(tmp);
X    do_maploop(last);
X}
X
X/* xforeach - built-in function 'for-each' */
XLVAL xforeach()
X{
X    if (xlargc < 2) xltoofew();
X    do_forloop();
X}
X
X/* do_forloop - setup for the next application */
Xdo_forloop()
X{
X    extern LVAL cs_foreach1;
X    LVAL *oldsp,*p,x;
X    int cnt;
X
X    /* get a pointer to the end of the argument list */
X    p = &xlsp[xlargc];
X    oldsp = xlsp;
X
X    /* save a continuation */
X    check(3);
X    push(cvfixnum((FIXTYPE)xlargc));
X    push(cs_foreach1);
X    push(xlenv);
X
X    /* build the argument list for the next application */
X    for (cnt = xlargc; --cnt >= 1; ) {
X    x = *--p;
X    if (consp(x)) {
X        cpush(car(x));
X        *p = cdr(x);
X    }
X    else {
X        xlsp = oldsp;
X        drop(xlargc);
X        xlval = NIL;
X        xlreturn();
X        return;
X    }
X    }
X    xlval = *--p;    /* get the function to apply */
X    xlargc -= 1;    /* count shouldn't include the function itself */
X    xlapply();        /* apply the function */
X}
X
X/* xforeach1 - continuation for xforeach */
XLVAL xforeach1()
X{
X    LVAL tmp;
X
X    /* get the argument count */
X    tmp = pop();
X
X    /* convert the argument count and loop */
X    xlargc = (int)getfixnum(tmp);
X    do_forloop();
X}
X
X/* xcallwi - built-in function 'call-with-input-file' */
XLVAL xcallwi()
X{
X    do_withfile(PF_INPUT,"r");
X}
X
X/* xcallwo - built-in function 'call-with-output-file' */
XLVAL xcallwo()
X{
X    do_withfile(PF_OUTPUT,"w");
X}
X
X/* do_withfile - handle the 'call-with-xxx-file' functions */
Xdo_withfile(flags,mode)
X  int flags; char *mode;
X{
X    extern LVAL cs_withfile1;
X    extern FILE *osaopen();
X    LVAL name,file;
X    FILE *fp;
X
X    /* get the function to call */
X    name = xlgastring();
X    xlval = xlgetarg();
X    xllastarg();
X
X    /* create a file object */
X    file = cvport(NULL,flags);
X    if ((fp = osaopen(getstring(name),mode)) == NULL)
X    xlerror("can't open file",name);
X    setfile(file,fp);
X
X    /* save a continuation */
X    check(3);
X    push(file);
X    push(cs_withfile1);
X    push(xlenv);
X
X    /* setup the argument list */
X    cpush(file);
X    xlargc = 1;
X
X    /* apply the function */
X    xlapply();
X}
X
X/* xwithfile1 - continuation for xcallwi and xcallwo */
XLVAL xwithfile1()
X{
X    osclose(getfile(top()));
X    setfile(pop(),NULL);
X    xlreturn();
X}
X
X/* xload - built-in function 'load' */
XLVAL xload()
X{
X    do_load(NIL);
X}
X
X/* xloadnoisily - built-in function 'load-noisily' */
XLVAL xloadnoisily()
X{
X    do_load(true);
X}
X
X/* do_load - open the file and setup the load loop */
Xdo_load(print)
X  LVAL print;
X{
X    extern FILE *osaopen();
X    LVAL file;
X    FILE *fp;
X
X    /* get the function to call */
X    xlval = xlgastring();
X    xllastarg();
X
X    /* create a file object */
X    file = cvport(NULL,PF_INPUT);
X    if ((fp = osaopen(getstring(xlval),"r")) == NULL) {
X    xlval = NIL;
X    xlreturn();
X    return;
X    }
X    setfile(file,fp);
X    xlval = file;
X
X    /* do the first read */
X    do_loadloop(print);
X}
X
X/* do_loadloop - read the next expression and setup to evaluate it */
Xdo_loadloop(print)
X  LVAL print;
X{
X    extern LVAL cs_load1,s_eval;
X    LVAL expr;
X
X    /* try to read the next expression from the file */
X    if (xlread(xlval,&expr)) {
X
X    /* save a continuation */
X    check(4);
X    push(xlval);
X    push(print);
X    push(cs_load1);
X    push(xlenv);
X
X    /* setup the argument list */
X    xlval = getvalue(s_eval);
X    cpush(expr);
X    xlargc = 1;
X
X    /* apply the function */
X    xlapply();
X    }
X    else {
X    osclose(getfile(xlval));
X    setfile(xlval,NULL);
X    xlval = true;
X    xlreturn();
X    }
X}
X
X/* xload1 - continuation for xload */
XLVAL xload1()
X{
X    LVAL print;
X
X    /* print the value if the print variable is set */
X    if (print = pop()) {
X    xlprin1(xlval,curoutput());
X    xlterpri(curoutput());
X    }
X    xlval = pop();
X
X    /* setup for the next read */
X    do_loadloop(print);
X}
X
X/* xforce - built-in function 'force' */
XLVAL xforce()
X{
X    extern LVAL cs_force1;
X
X    /* get the promise */
X    xlval = xlgetarg();
X    xllastarg();
X
X    /* check for a promise */
X    if (promisep(xlval)) {
X
X    /* force the promise the first time */
X    if ((xlfun = getpproc(xlval)) != NIL) {
X        check(3);
X        push(xlval);
X        push(cs_force1);
X        push(xlenv);
X        xlval = xlfun;
X        xlargc = 0;
X        xlapply();
X    }
X
X    /* return the saved value if the promise has already been forced */
X    else {
X        xlval = getpvalue(xlval);
X        xlreturn();
X    }
X
X    }
X
X    /* otherwise, just return the argument */
X    else
X    xlreturn();
X}
X
X/* xforce1 - continuation for xforce */
XLVAL xforce1()
X{
X    LVAL promise;
X    promise = pop();
X    setpvalue(promise,xlval);
X    setpproc(promise,NIL);
X    xlreturn();
X}
X
X/* xsymstr - built-in function 'symbol->string' */
XLVAL xsymstr()
X{
X    xlval = xlgasymbol();
X    xllastarg();
X    return (getpname(xlval));
X}
X
X/* xstrsym - built-in function 'string->symbol' */
XLVAL xstrsym()
X{
X    xlval = xlgastring();
X    xllastarg();
X    return (xlenter(getstring(xlval)));
X}
X
X/* xread - built-in function 'read' */
XLVAL xread()
X{
X    LVAL fptr,val;
X
X    /* get file pointer and eof value */
X    fptr = (moreargs() ? xlgaiport() : curinput());
X    xllastarg();
X
X    /* read an expression */
X    if (!xlread(fptr,&val))
X    val = eof_object;
X
X    /* return the expression */
X    return (val);
X}
X
X/* xrdchar - built-in function 'read-char' */
XLVAL xrdchar()
X{
X    LVAL fptr;
X    int ch;
X    fptr = (moreargs() ? xlgaiport() : curinput());
X    xllastarg();
X    return ((ch = xlgetc(fptr)) == EOF ? eof_object : cvchar(ch));
X}
X
X/* xrdbyte - built-in function 'read-byte' */
XLVAL xrdbyte()
X{
X    LVAL fptr;
X    int ch;
X    fptr = (moreargs() ? xlgaiport() : curinput());
X    xllastarg();
X    return ((ch = xlgetc(fptr)) == EOF ? eof_object : cvfixnum((FIXTYPE)ch));
X}
X
X/* xrdshort - built-in function 'read-short' */
XLVAL xrdshort()
X{
X    unsigned char *p;
X    short int val=0;
X    LVAL fptr;
X    int ch,n;
X    fptr = (moreargs() ? xlgaiport() : curinput());
X    xllastarg();
X    for (n = sizeof(short int), p = (unsigned char *)&val; --n >= 0; ) {
X        if ((ch = xlgetc(fptr)) == EOF)
X        return (eof_object);
X        *p++ = ch;
X    }
X    return (cvfixnum((FIXTYPE)val));
X}
X
X/* xrdlong - built-in function 'read-long' */
XLVAL xrdlong()
X{
X    unsigned char *p;
X    long int val=0;
X    LVAL fptr;
X    int ch,n;
X    fptr = (moreargs() ? xlgaiport() : curinput());
X    xllastarg();
X    for (n = sizeof(long int), p = (unsigned char *)&val; --n >= 0; ) {
X        if ((ch = xlgetc(fptr)) == EOF)
X        return (eof_object);
X        *p++ = ch;
X    }
X    return (cvfixnum((FIXTYPE)val));
X}
X
X/* xeofobjectp - built-in function 'eof-object?' */
XLVAL xeofobjectp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (arg == eof_object ? true : NIL);
X}
X
X/* xwrite - built-in function 'write' */
XLVAL xwrite()
X{
X    LVAL fptr,val;
X
X    /* get expression to print and file pointer */
X    val = xlgetarg();
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X
X    /* print the value */
X    xlprin1(val,fptr);
X    return (true);
X}
X
X/* xprint - built-in function 'print' */
XLVAL xprint()
X{
X    LVAL fptr,val;
X
X    /* get expression to print and file pointer */
X    val = xlgetarg();
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X
X    /* print the value */
X    xlprin1(val,fptr);
X    xlterpri(fptr);
X    return (true);
X}
X
X/* xwrchar - built-in function 'write-char' */
XLVAL xwrchar()
X{
X    LVAL fptr,ch;
X    ch = xlgachar();
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X    xlputc(fptr,(int)getchcode(ch));
X    return (true);
X}
X
X/* xwrbyte - built-in function 'write-byte' */
XLVAL xwrbyte()
X{
X    LVAL fptr,ch;
X    ch = xlgafixnum();
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X    xlputc(fptr,(int)getfixnum(ch));
X    return (true);
X}
X
X/* xwrshort - built-in function 'write-short' */
XLVAL xwrshort()
X{
X    unsigned char *p;
X    short int val;
X    LVAL fptr,v;
X    int n;
X    v = xlgafixnum(); val = (short int)getfixnum(v);
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X    for (n = sizeof(short int), p = (unsigned char *)&val; --n >= 0; )
X        xlputc(fptr,*p++);
X    return (true);
X}
X
X/* xwrlong - built-in function 'write-long' */
XLVAL xwrlong()
X{
X    unsigned char *p;
X    long int val;
X    LVAL fptr,v;
X    int n;
X    v = xlgafixnum(); val = (long int)getfixnum(v);
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X    for (n = sizeof(long int), p = (unsigned char *)&val; --n >= 0; )
X        xlputc(fptr,*p++);
X    return (true);
X}
X
X/* xdisplay - built-in function 'display' */
XLVAL xdisplay()
X{
X    LVAL fptr,val;
X
X    /* get expression to print and file pointer */
X    val = xlgetarg();
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X
X    /* print the value */
X    xlprinc(val,fptr);
X    return (true);
X}
X
X/* xnewline - terminate the current print line */
XLVAL xnewline()
X{
X    LVAL fptr;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X
X    /* terminate the print line and return nil */
X    xlterpri(fptr);
X    return (true);
X}
X
X/* xprbreadth - set the maximum number of elements to be printed */
XLVAL xprbreadth()
X{
X    return (setit(&prbreadth));
X}
X
X/* xprdepth - set the maximum depth of nested lists to be printed */
XLVAL xprdepth()
X{
X    return (setit(&prdepth));
X}
X
X/* setit - common routine for prbreadth/prdepth */
XLOCAL LVAL setit(pvar)
X  int *pvar;
X{
X    LVAL arg;
X
X    /* get the optional argument */
X    if (moreargs()) {
X    arg = xlgetarg();
X    xllastarg();
X    *pvar = (fixp(arg) ? (int)getfixnum(arg) : -1);
X    }
X
X    /* return the value of the variable */
X    return (*pvar >= 0 ? cvfixnum((FIXTYPE)*pvar) : NIL);
X}
X
X/* xopeni - built-in function 'open-input-file' */
XLVAL xopeni()
X{
X    LVAL openfile();
X    return (openfile(PF_INPUT,"r"));
X}
X
X/* xopeno - built-in function 'open-output-file' */
XLVAL xopeno()
X{
X    LVAL openfile();
X    return (openfile(PF_OUTPUT,"w"));
X}
X
X/* xopena - built-in function 'open-append-file' */
XLVAL xopena()
X{
X    LVAL openfile();
X    return (openfile(PF_OUTPUT,"a"));
X}
X
X/* xopenu - built-in function 'open-update-file' */
XLVAL xopenu()
X{
X    LVAL openfile();
X    return (openfile(PF_INPUT|PF_OUTPUT,"r+"));
X}
X
X/* openfile - open an ascii or binary file */
XLOCAL LVAL openfile(flags,mode)
X  int flags; char *mode;
X{
X    extern FILE *osaopen(),*osbopen();
X    LVAL file,modekey;
X    char *name;
X    FILE *fp;
X
X    /* get the file name and direction */
X    name = (char *)getstring(xlgastring());
X    modekey = (moreargs() ? xlgasymbol() : NIL);
X    xllastarg();
X
X    /* check for binary mode */
X    if (modekey != NIL) {
X    if (modekey == xlenter("BINARY"))
X        flags |= PF_BINARY;
X    else if (modekey != xlenter("TEXT"))
X        xlerror("unrecognized open mode",modekey);
X    }
X
X    /* try to open the file */
X    file = cvport(NULL,flags);
X    fp = ((flags & PF_BINARY) == 0 ? osaopen(name,mode) : osbopen(name,mode));
X    if (fp == NULL)
X    return (NIL);
X    setfile(file,fp);
X    return (file);
X}
X
X/* xclose - built-in function 'close-port' */
XLVAL xclose()
X{
X    LVAL fptr;
X    fptr = xlgaport();
X    xllastarg();
X    if (getfile(fptr))
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X    return (NIL);
X}
X
X/* xclosei - built-in function 'close-input-port' */
XLVAL xclosei()
X{
X    LVAL fptr;
X    fptr = xlgaiport();
X    xllastarg();
X    if (getfile(fptr))
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X    return (NIL);
X}
X
X/* xcloseo - built-in function 'close-output-port' */
XLVAL xcloseo()
X{
X    LVAL fptr;
X    fptr = xlgaoport();
X    xllastarg();
X    if (getfile(fptr))
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X    return (NIL);
X}
X
X/* xgetfposition - built-in function 'get-file-position' */
XLVAL xgetfposition()
X{
X    extern long ostell();
X    LVAL fptr;
X    fptr = xlgaport();
X    xllastarg();
X    return (cvfixnum(ostell(getfile(fptr))));
X}
X
X/* xsetfposition - built-in function 'set-file-position!' */
XLVAL xsetfposition()
X{
X    LVAL fptr,val;
X    long position;
X    int whence;
X    fptr = xlgaport();
X    val = xlgafixnum(); position = getfixnum(val);
X    val = xlgafixnum(); whence = (int)getfixnum(val);
X    xllastarg();
X    return (osseek(getfile(fptr),position,whence) == 0 ? true : NIL);
X}
X
X/* xcurinput - built-in function 'current-input-port' */
XLVAL xcurinput()
X{
X    xllastarg();
X    return (curinput());
X}
X
X/* xcuroutput - built-in function 'current-output-port' */
XLVAL xcuroutput()
X{
X    xllastarg();
X    return (curoutput());
X}
X
X/* xportp - built-in function 'port?' */
XLVAL xportp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (portp(arg) ? true : NIL);
X}
X
X/* xinputportp - built-in function 'input-port?' */
XLVAL xinputportp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (iportp(arg) ? true : NIL);
X}
X
X/* xoutputportp - built-in function 'output-port?' */
XLVAL xoutputportp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (oportp(arg) ? true : NIL);
X}
X
X/* xtranson - built-in function 'transcript-on' */
XLVAL xtranson()
X{
X    extern FILE *osaopen();
X    char *name;
X
X    /* get the file name and direction */
X    name = (char *)getstring(xlgastring());
X    xllastarg();
X
X    /* close any currently open transcript file */
X    if (tfp) { osclose(tfp); tfp = NULL; }
X
X    /* try to open the file */
X    return ((tfp = osaopen(name,"w")) == NULL ? NIL : true);
X}
X
X/* xtransoff - built-in function 'transcript-off' */
XLVAL xtransoff()
X{
X    /* make sure there aren't any arguments */
X    xllastarg();
X
X    /* make sure the transcript is open */
X    if (tfp == NULL)
X    return (NIL);
X
X    /* close the transcript and return successfully */
X    osclose(tfp); tfp = NULL;
X    return (true);
X}
X
X/* xstrlen - built-in function 'string-length' */
XLVAL xstrlen()
X{
X    LVAL str;
X    str = xlgastring();
X    xllastarg();
X    return (cvfixnum((FIXTYPE)(getslength(str)-1)));
X}
X
X/* xstrnullp - built-in function 'string-null?' */
XLVAL xstrnullp()
X{
X    LVAL str;
X    str = xlgastring();
X    xllastarg();
X    return (getslength(str) == 1 ? true : NIL);
X}
X
X/* xstrappend - built-in function 'string-append' */
XLVAL xstrappend()
X{
X    LVAL *savesp,tmp,val;
X    unsigned char *str;
X    int saveargc,len;
X
X    /* save the argument list */
X    saveargc = xlargc;
X    savesp = xlsp;
X
X    /* find the length of the new string */
X    for (len = 0; moreargs(); ) {
X    tmp = xlgastring();
X    len += (int)getslength(tmp) - 1;
X    }
X
X    /* restore the argument list */
X    xlargc = saveargc;
X    xlsp = savesp;
X
X    /* create the result string */
X    val = newstring(len+1);
X    str = getstring(val);
X
X    /* combine the strings */
X    for (*str = '\0'; moreargs(); ) {
X    tmp = nextarg();
X    strcat(str,getstring(tmp));
X    }
X
X    /* return the new string */
X    return (val);
X}
X
X/* xstrref - built-in function 'string-ref' */
XLVAL xstrref()
X{
X    LVAL str,num;
X    int n;
X
X    /* get the string and the index */
X    str = xlgastring();
X    num = xlgafixnum();
X    xllastarg();
X
X    /* range check the index */
X    if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
X    xlerror("index out of range",num);
X
X    /* return the character */
X    return (cvchar(getstring(str)[n]));
X}
X
X/* xsubstring - built-in function 'substring' */
XLVAL xsubstring()
X{
X    unsigned char *srcp,*dstp;
X    int start,end,len;
X    LVAL src,dst;
X
X    /* get string and starting and ending positions */
X    src = xlgastring();
X
X    /* get the starting position */
X    dst = xlgafixnum(); start = (int)getfixnum(dst);
X    if (start < 0 || start > getslength(src) - 1)
X    xlerror("index out of range",dst);
X
X    /* get the ending position */
X    if (moreargs()) {
X    dst = xlgafixnum(); end = (int)getfixnum(dst);
X    if (end < 0 || end > getslength(src) - 1)
X        xlerror("index out of range",dst);
X    }
X    else
X    end = getslength(src) - 1;
X    xllastarg();
X
X    /* setup the source pointer */
X    srcp = getstring(src) + start;
X    len = end - start;
X
X    /* make a destination string and setup the pointer */
X    dst = newstring(len+1);
X    dstp = getstring(dst);
X
X    /* copy the source to the destination */
X    while (--len >= 0)
X    *dstp++ = *srcp++;
X    *dstp = '\0';
X
X    /* return the substring */
X    return (dst);
X}
X
X/* xstrlist - built-in function 'string->list' */
XLVAL xstrlist()
X{
X    unsigned char *p;
X    LVAL str;
X    int size;
X
X    /* get the vector */
X    str = xlgastring();
X    xllastarg();
X
X    /* make a list from the vector */
X    cpush(str);
X    size = getslength(str)-1;
X    for (xlval = NIL, p = &getstring(str)[size]; --size >= 0; )
X    xlval = cons(cvchar(*--p),xlval);
X    drop(1);
X    return (xlval);
X}
X
X/* xliststring - built-in function 'list->string' */
XLVAL xliststring()
X{
X    unsigned char *p;
X    LVAL str;
X    int size;
X
X    /* get the list */
X    xlval = xlgalist();
X    xllastarg();
X
X    /* make a vector from the list */
X    size = length(xlval);
X    str = newstring(size+1);
X    for (p = getstring(str); --size >= 0; xlval = cdr(xlval))
X    if (charp(car(xlval)))
X        *p++ = getchcode(car(xlval));
X    else
X        xlbadtype(car(xlval));
X    *p = '\0';
X    return (str);
X}
X
X/* string comparision functions */
XLVAL xstrlss() { return (strcompare('<',FALSE)); } /* string<? */
XLVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<=? */
XLVAL xstreql() { return (strcompare('=',FALSE)); } /* string=? */
XLVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>=? */
XLVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string>? */
X
X/* string comparison functions (case insensitive) */
XLVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-ci<? */
XLVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-ci<=? */
XLVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-ci=? */
XLVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-ci>=? */
XLVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-ci>? */
X
X/* strcompare - compare strings */
XLOCAL LVAL strcompare(fcn,icase)
X  int fcn,icase;
X{
X    int start1,end1,start2,end2,ch1,ch2;
X    unsigned char *p1,*p2;
X    LVAL str1,str2;
X
X    /* get the strings */
X    str1 = xlgastring();
X    str2 = xlgastring();
X    xllastarg();
X
X    /* setup the string pointers */
X    p1 = getstring(str1); start1 = 0; end1 = getslength(str1);
X    p2 = getstring(str2); start2 = 0; end2 = getslength(str2);
X
X    /* compare the strings */
X    for (; start1 < end1 && start2 < end2; ++start1,++start2) {
X    ch1 = *p1++;
X    ch2 = *p2++;
X    if (icase) {
X        if (isupper(ch1)) ch1 = tolower(ch1);
X        if (isupper(ch2)) ch2 = tolower(ch2);
X    }
X    if (ch1 != ch2)
X        switch (fcn) {
X        case '<':    return (ch1 < ch2 ? true : NIL);
X        case 'L':    return (ch1 <= ch2 ? true : NIL);
X        case '=':    return (NIL);
X        case 'G':    return (ch1 >= ch2 ? true : NIL);
X        case '>':    return (ch1 > ch2 ? true : NIL);
X        }
X    }
X
X    /* check the termination condition */
X    switch (fcn) {
X    case '<':    return (start1 >= end1 && start2 < end2 ? true : NIL);
X    case 'L':    return (start1 >= end1 ? true : NIL);
X    case '=':    return (start1 >= end1 && start2 >= end2 ? true : NIL);
X    case 'G':    return (start2 >= end2 ? true : NIL);
X    case '>':    return (start2 >= end2 && start1 < end1 ? true : NIL);
X    }
X}
X
X/* xcharint - built-in function 'char->integer' */
XLVAL xcharint()
X{
X    LVAL arg;
X    arg = xlgachar();
X    xllastarg();
X    return (cvfixnum((FIXTYPE)getchcode(arg)));
X}
X
X/* xintchar - built-in function 'integer->char' */
XLVAL xintchar()
X{
X    LVAL arg;
X    arg = xlgafixnum();
X    xllastarg();
X    return (cvchar((int)getfixnum(arg)));
X}
X
X/* character comparision functions */
XLVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char<? */
XLVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<=? */
XLVAL xchreql() { return (chrcompare('=',FALSE)); } /* char=? */
XLVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>=? */
XLVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char>? */
X
X/* character comparision functions (case insensitive) */
XLVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-ci<? */
XLVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-ci<=? */
XLVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-ci=? */
XLVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-ci>=? */
XLVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-ci>? */
X
X/* chrcompare - compare characters */
XLOCAL LVAL chrcompare(fcn,icase)
X  int fcn,icase;
X{
X    int ch1,ch2;
X    LVAL arg;
X
X    /* get the characters */
X    arg = xlgachar(); ch1 = getchcode(arg);
X    arg = xlgachar(); ch2 = getchcode(arg);
X    xllastarg();
X
X    /* convert to lowercase if case insensitive */
X    if (icase) {
X    if (isupper(ch1)) ch1 = tolower(ch1);
X    if (isupper(ch2)) ch2 = tolower(ch2);
X    }
X
X    /* compare the characters */
X    switch (fcn) {
X    case '<':    return (ch1 < ch2 ? true : NIL);
X    case 'L':    return (ch1 <= ch2 ? true : NIL);
X    case '=':    return (ch1 == ch2 ? true : NIL);
X    case 'G':    return (ch1 >= ch2 ? true : NIL);
X    case '>':    return (ch1 > ch2 ? true : NIL);
X    }
X}
X
X/* xcompile - built-in function 'compile' */
XLVAL xcompile()
X{
X    extern LVAL xlcompile();
X    LVAL env;
X
X    /* get the expression to compile and the environment */
X    xlval = xlgetarg();
X    env = (moreargs() ? xlgaenv() : NIL);
X    xllastarg();
X
X    /* build the closure */
X    cpush(env);
X    xlval = xlcompile(xlval,env);
X    xlval = cvclosure(xlval,env);
X    drop(1);
X    return (xlval);
X}
X
X/* xdecompile - built-in function 'decompile' */
XLVAL xdecompile()
X{
X    LVAL fun,fptr;
X
X    /* get the closure (or code) and file pointer */
X    fun = xlgetarg();
X    fptr = (moreargs() ? xlgaoport() : curoutput());
X    xllastarg();
X
X    /* make sure we got either a closure or a code object */
X    if (!closurep(fun) && !methodp(fun))
X    xlbadtype(fun);
X
X    /* decompile (disassemble) the procedure */
X    decode_procedure(fptr,fun);
X    return (NIL);
X}
X
X/* xsave - save the memory image */
XLVAL xsave()
X{
X    unsigned char *name;
X
X    /* get the file name, verbose flag and print flag */
X    name = getstring(xlgastring());
X    xllastarg();
X
X    /* save the memory image */
X    return (xlisave(name) ? true : NIL);
X}
X
X/* xrestore - restore a saved memory image */
XLVAL xrestore()
X{
X    extern jmp_buf top_level;
X    unsigned char *name;
X
X    /* get the file name, verbose flag and print flag */
X    name = getstring(xlgastring());
X    xllastarg();
X
X    /* restore the saved memory image */
X    if (!xlirestore(name))
X    return (NIL);
X
X    /* return directly to the top level */
X    stdputstr("[ returning to the top level ]\n");
X    longjmp(top_level,1);
X}
X
X/* xgc - function to force garbage collection */
XLVAL xgc()
X{
X    extern FIXTYPE nnodes,nfree,gccalls,total;
X    extern int nscount,vscount;
X    int arg1,arg2;
X    LVAL arg;
X
X    /* check the argument list and call the garbage collector */
X    if (moreargs()) {
X    arg = xlgafixnum(); arg1 = (int)getfixnum(arg);
X    arg = xlgafixnum(); arg2 = (int)getfixnum(arg);
X    xllastarg();
X    nexpand(arg1);
X    vexpand(arg2);
X    }
X    else
X    gc();
X
X    /* return (gccalls nnodes nfree nscount vscount total) */
X    xlval = cons(cvfixnum(total),NIL);
X    xlval = cons(cvfixnum((FIXTYPE)vscount),xlval);
X    xlval = cons(cvfixnum((FIXTYPE)nscount),xlval);
X    xlval = cons(cvfixnum(nfree),xlval);
X    xlval = cons(cvfixnum(nnodes),xlval);
X    xlval = cons(cvfixnum(gccalls),xlval);
X    return (xlval);
X}
X
X/* xerror - built-in function 'error' */
XLVAL xerror()
X{
X    extern jmp_buf top_level;
X    LVAL msg;
X
X    /* display the error message */
X    msg = xlgastring();
X    errputstr("error: ");
X    errputstr(getstring(msg));
X    errputstr("\n");
X
X    /* print each of the remaining arguments on separate lines */
X    while (moreargs()) {
X    errputstr("  ");
X    errprint(xlgetarg());
X    }
X
X    /* print the function where the error occurred */
X    errputstr("happened in: ");
X    errprint(xlfun);
X
X    /* call the handler */
X    callerrorhandler();
X}
X
X/* xreset - built-in function 'reset' */
XLVAL xreset()
X{
X    extern jmp_buf top_level;
X    xllastarg();
X    longjmp(top_level,1);
X}
X
X/* xgetarg - return a command line argument */
XLVAL xgetarg()
X{
X    extern char **clargv;
X    extern int clargc;
X    LVAL arg;
X    int n;
X    arg = xlgafixnum(); n = (int)getfixnum(arg);
X    xllastarg();
X    return (n >= 0 && n < clargc ? cvstring(clargv[n]) : NIL);
X}
X
X/* xexit - exit to the operating system */
XLVAL xexit()
X{
X    xllastarg();
X    wrapup();
X}
END_OF_FILE
if test 27271 -ne `wc -c <'Src/xsfun2.c'`; then
    echo shar: \"'Src/xsfun2.c'\" unpacked with wrong size!
fi
# end of 'Src/xsfun2.c'
fi
echo shar: End of archive 4 \(of 7\).
cp /dev/null ark4isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 7 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <[e-mail]>.
Mail comments to the moderator at <[e-mail]>.
Post requests for sources, and general discussion to comp.sys.amiga.